home *** CD-ROM | disk | FTP | other *** search
- unit Handles;
-
- { TStretchHandles is a transparent control to implement runtime grab handles
- for Forms Designer-like projects. It paints the handles on its own canvas,
- maintains a list of the controls it is supposed to manage, and traps mouse
- and keyboard events to move/resize itself and its child controls. See the
- accompanying README file for more information.
-
- Distributed by the author as freeware, please do not sell.
-
- Anthony Scott
- CIS: 75567,3547 }
-
- interface
-
- uses
- SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
- Forms, Menus, StdCtrls, Dialogs;
- { miscellaneous type declarations }
- type
- TDragStyle = (dsMove, dsSizeTopLeft, dsSizeTopRight, dsSizeBottomLeft, dsSizeBottomRight,
- dsSizeTop, dsSizeLeft, dsSizeBottom, dsSizeRight);
- TForwardMessage = (fmMouseDown, fmMouseUp);
- GridValues = 1..32;
- EBadChild = class(Exception);
- { TStretchHandle component declaration }
- type
- TStretchHandle = class(TCustomControl)
- private
- FDragOffset: TPoint;
- FDragStyle: TDragStyle;
- FDragging: boolean;
- FDragRect: TRect;
- FLocked: boolean;
- FPrimaryColor: TColor;
- FSecondaryColor: TColor;
- FGridX, FGridY: GridValues;
- FChildList: TList;
- procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
- procedure WMGetDLGCode(var Message: TMessage); message WM_GETDLGCODE;
- procedure Rubberband(XPos, YPos: integer; ShowBox: boolean);
- procedure ForwardMessage(FwdMsg: TForwardMessage; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
- procedure SetPrimaryColor(Color: TColor);
- procedure SetSecondaryColor(Color: TColor);
- procedure SetGridState(Value: boolean);
- function GetGridState: boolean;
- function GetChildCount: integer;
- function GetChildControl(idx: integer): TControl;
- function GetModifiedRect(XPos, YPos: integer): TRect;
- function PointOverChild(P: TPoint): boolean;
- function XGridAdjust(X: integer): integer;
- function YGridAdjust(Y: integer): integer;
- function IsAttached: boolean;
- protected
- procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
- procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
- procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
- procedure KeyDown(var key: Word; Shift: TShiftState); override;
- procedure CreateParams(var Params: TCreateParams); override;
- procedure Paint; override;
- property Canvas;
- public
- constructor Create(AOwner: TComponent); override;
- destructor Destroy; override;
- procedure Attach(ChildControl: TControl);
- procedure Detach;
- procedure ReleaseChild(ChildControl: TControl);
- procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
- procedure BringToFront;
- procedure SendToBack;
- procedure SetColors(Color1, Color2: TColor);
- function IndexOf(ChildControl: TControl): integer;
- { new run-time only properties }
- property Attached: boolean read IsAttached;
- property ChildCount: integer read GetChildCount;
- property Children[idx: integer]: TControl read GetChildControl;
- published
- { new properties }
- property Color: TColor read FPrimaryColor write SetPrimaryColor default clBlack;
- property SecondaryColor: TColor read FSecondaryColor write SetSecondaryColor default clGray;
- property Locked: boolean read FLocked write FLocked default False;
- property GridX: GridValues read FGridX write FGridX default 8;
- property GridY: GridValues read FGridY write FGridY default 8;
- property SnapToGrid: boolean read GetGridState write SetGridState default False;
- { inherited properties }
- property DragCursor;
- property Enabled;
- property Hint;
- property ParentShowHint;
- property PopupMenu;
- property ShowHint;
- property Visible;
- { defined events }
- property OnClick;
- property OnDblClick;
- property OnMouseDown;
- property OnMouseMove;
- property OnMouseUp;
- property OnKeyDown;
- property OnKeyUp;
- property OnKeyPress;
- end;
-
- procedure Register;
- function MinInt(a, b: integer): integer;
- function MaxInt(a, b: integer): integer;
-
- implementation
-
- procedure Register;
- begin
- { add the component to the 'Samples' tab }
- RegisterComponents('Samples', [TStretchHandle]);
-
- end;
-
- constructor TStretchHandle.Create(AOwner: TComponent);
- begin
-
- inherited Create(AOwner);
- { create storage for child objects }
- FChildList := TList.Create;
- { initialize default properties }
- Width := 24;
- Height := 24;
- FPrimaryColor := clBlack;
- FSecondaryColor := clGray;
- { a value of 1 is used to effectively disable the snap-to grid }
- FGridX := 1;
- FGridY := 1;
- { doesn't do anything until it is Attached to something else }
- Enabled := False;
- Visible := False;
-
- end;
-
- destructor TStretchHandle.Destroy;
- begin
- { tidy up carefully }
- FChildList.Free;
- inherited Destroy;
-
- end;
-
- procedure TStretchHandle.CreateParams(var Params: TCreateParams);
- begin
- { set default Params values }
- inherited CreateParams(Params);
- { then add transparency; ensures correct repaint order }
- Params.ExStyle := Params.ExStyle + WS_EX_TRANSPARENT;
-
- end;
-
- procedure TStretchHandle.WMGetDLGCode(var Message: TMessage);
- begin
- { get arrow key press events }
- Message.Result := DLGC_WANTARROWS;
-
- end;
-
- procedure TStretchHandle.WMEraseBkgnd(var Message: TWMEraseBkgnd);
- begin
- { completely fake erase, don't call inherited, don't collect $200 }
- Message.Result := 1;
-
- end;
-
- procedure TStretchHandle.Attach(ChildControl: TControl);
- var
- L, T, W, H: integer;
- begin
- { definitely not allowed! }
- if ChildControl is TForm then
- raise EBadChild.Create('Handles can not be attached to a Form!');
- { add child component to unique list managed by TStretchHandle }
- if (ChildControl <> nil) and (FChildList.IndexOf(TObject(ChildControl)) = -1) then
- begin
- { make sure new child's Parent matches siblings }
- if (FChildList.Count > 0) and (ChildControl.Parent <> Parent) then
- Detach;
- { initialize when first child is attached }
- if FChildList.Count = 0 then
- begin
- Parent := ChildControl.Parent;
- { only make it visible now, to avoid color flashing, & accept events }
- FDragRect := Rect(0, 0, 0, 0);
- Enabled := True;
- Visible := True;
- inherited SetBounds(ChildControl.Left - 2, ChildControl.Top - 2, ChildControl.Width + 5, ChildControl.Height + 5);
-
- end
- else
- begin
- { set size to bound all children, plus room for handles }
- L := MinInt(Left, ChildControl.Left - 2);
- T := MinInt(Top, ChildControl.Top - 2);
- W := Maxint(Left + Width - 3, ChildControl.Left + ChildControl.Width) - L + 3;
- H := Maxint(Top + Height - 3, ChildControl.Top + ChildControl.Height) - T + 3;
- inherited SetBounds(L, T, W, H);
-
- end;
- { add to list of active Children }
- FChildList.Add(TObject(ChildControl));
- { re-set DragStyle }
- FDragStyle := dsMove;
- { use old BringToFront so as not to change Child's Z-order }
- if not (csDesigning in ComponentState) then
- begin
- inherited BringToFront;
- { allow us to get Mouse events immediately! }
- SetCapture(Handle);
- { get keyboard events }
- if Visible and Enabled then
- SetFocus;
- end;
-
- end;
-
- end;
-
- procedure TStretchHandle.Detach;
- begin
- { remove all Child components from list }
- if FChildList.Count > 0 then
- with FChildList do
- repeat
- Delete(0);
- until Count = 0;
- { disable & hide StretchHandle }
- FLocked := False;
- Width := 24;
- Height := 24;
- Enabled := False;
- Visible := False;
- Parent := nil;
- FDragRect := Rect(0, 0, 0, 0);
-
- end;
-
- procedure TStretchHandle.ReleaseChild(ChildControl: TControl);
- var
- idx, L, T, W, H: integer;
- AControl: TControl;
- begin
- { delete the Child if it exists in the list }
- idx := FChildList.IndexOf(TObject(ChildControl));
- if (ChildControl <> nil) and (idx >= 0) then
- FChildList.Delete(idx);
- { disable & hide StretchHandle if no more children }
- if FChildList.Count = 0 then
- begin
- FLocked := False;
- Enabled := False;
- Visible := False;
- Parent := nil;
- FDragRect := Rect(0, 0, 0, 0);
- end
- else
- begin
- { set size to bound remaining children, plus room for handles }
- L := TControl(FChildList.Items[0]).Left - 2;
- T := TControl(FChildList.Items[0]).Top - 2;
- W := TControl(FChildList.Items[0]).Width + 3;
- H := TControl(FChildList.Items[0]).Height + 3;
-
- for idx := 0 to FChildList.Count - 1 do
- begin
- AControl := TControl(FChildList.Items[idx]);
- L := MinInt(L, AControl.Left - 2);
- T := MinInt(T, AControl.Top - 2);
- W := Maxint(L + W - 3, AControl.Left + AControl.Width) - L + 3;
- H := Maxint(T + H - 3, AControl.Top + AControl.Height) - T + 3;
- end;
-
- inherited SetBounds(L, T, W, H);
-
- end;
-
- end;
-
- function TStretchHandle.IndexOf(ChildControl: TControl): integer;
- begin
- { simply pass on the result... }
- Result := FChildList.IndexOf(TObject(ChildControl));
-
- end;
-
- procedure TStretchHandle.BringToFront;
- var
- i: integer;
- begin
- { do nothing if not Attached }
- if Attached and not Locked then
- begin
- { take care of Children first, in Attach order }
- for i := 0 to FChildList.Count - 1 do
- begin
- TControl(FChildList[i]).BringToFront;
- end;
- { make sure keyboard focus is restored }
- inherited BringToFront;
- if Visible and Enabled then
- SetFocus;
- end;
-
- end;
-
- procedure TStretchHandle.SendToBack;
- var
- i: integer;
- begin
- { do nothing if not Attached }
- if Attached and not Locked then
- begin
- { take care of Children first, in Attach order }
- for i := 0 to FChildList.Count - 1 do
- begin
- TControl(FChildList[i]).SendToBack;
- end;
- { Handles stay in front of everything, always }
- inherited BringToFront;
- if Visible and Enabled then
- SetFocus;
- end;
-
- end;
-
- procedure TStretchHandle.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
- begin
- { only process MouseDown if it is over a Child, else forward }
- if PointOverChild(Point(Left + X, Top + Y)) then
- begin
- if (Button = mbLeft) and not FLocked then
- begin
- FDragOffset := Point(X, Y);
- FDragging := True;
- end;
- inherited MouseDown(Button, Shift, X, Y);
- end
- else
- begin
- Cursor := crDefault;
- SetCursor(Screen.Cursors[Cursor]);
- ForwardMessage(fmMouseDown, Button, Shift, Left + X, Top + Y);
- end;
-
- end;
-
- procedure TStretchHandle.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
- var
- ARect: TRect;
- begin
- { resize, reposition if anything changed }
- if FDragging and (Button = mbLeft) then
- begin
- { disallow drop off Parent }
- if (Left + X) < 0 then
- X := -Left;
- if (Top + Y) < 0 then
- Y := -Top;
- if (Left + X) > Parent.Width then
- X := Parent.Width - Left;
- if (Top + Y) > Parent.Height then
- Y := Parent.Height - Top;
- { force Paint when size doesn't change but position does }
- if (X <> FDragOffset.X) or (Y <> FDragOffset.Y) then
- begin
- Invalidate;
- ARect := GetModifiedRect(X, Y);
- SetBounds(ARect.Left, ARect.Top, ARect.Right, ARect.Bottom);
- end;
- { clear drag outline }
- RubberBand(0, 0, False);
- { seem to need this for keyboard events }
- if Visible and Enabled then
- SetFocus;
-
- FDragging := False;
- Cursor := crDefault;
- ReleaseCapture;
- { perform default processing }
- inherited MouseUp(Button, Shift, X, Y);
-
- end
- else
- ForwardMessage(fmMouseUp, Button, Shift, Left + X, Top + Y);
-
- end;
-
- procedure TStretchHandle.MouseMove(Shift: TShiftState; X, Y: Integer);
- var
- ARect: TRect;
- DragStyle: TDragStyle;
- begin
- { this may be a move immediately on Attach instead of MouseDown }
- if (ssLeft in Shift) and not FDragging and not FLocked then
- begin
- FDragOffset := Point(X, Y);
- FDragging := True;
- end
- { only recognize move after simulated MouseDown }
- else
- begin
- { let's not hog mouse events unnecessarily }
- if not (ssLeft in Shift) then
- ReleaseCapture;
- { default to drag cursor only when dragging }
- DragStyle := dsMove;
- Cursor := crDefault;
- { disallow resize if multiple children }
- if FChildList.Count = 1 then
- begin
-
- ARect := GetClientRect;
- { so I don't like long nested if statements... }
- if ((Abs(X - ARect.Left) < 5) and (Abs(Y - ARect.Top) < 5)) then
- begin
- DragStyle := dsSizeTopLeft;
- Cursor := crSizeNWSE;
- end;
-
- if ((Abs(X - ARect.Right) < 5) and (Abs(Y - ARect.Bottom) < 5)) then
- begin
- DragStyle := dsSizeBottomRight;
- Cursor := crSizeNWSE;
- end;
-
- if ((Abs(X - ARect.Right) < 5) and (Abs(Y - ARect.Top) < 5)) then
- begin
- DragStyle := dsSizeTopRight;
- Cursor := crSizeNESW;
- end;
-
- if ((Abs(X - ARect.Left) < 5) and (Abs(Y - ARect.Bottom) < 5)) then
- begin
- DragStyle := dsSizeBottomLeft;
- Cursor := crSizeNESW;
- end;
-
- if ((Abs(X - trunc(ARect.Right - ARect.Left) / 2) < 3) and (Abs(Y - ARect.Top) < 5)) then
- begin
- DragStyle := dsSizeTop;
- Cursor := crSizeNS;
- end;
-
- if ((Abs(X - trunc(ARect.Right - ARect.Left) / 2) < 3) and (Abs(Y - ARect.Bottom) < 5)) then
- begin
- DragStyle := dsSizeBottom;
- Cursor := crSizeNS;
- end;
-
- if ((Abs(Y - trunc(ARect.Bottom - ARect.Top) / 2) < 3) and (Abs(X - ARect.Left) < 5)) then
- begin
- DragStyle := dsSizeLeft;
- Cursor := crSizeWE;
- end;
-
- if ((Abs(Y - trunc(ARect.Bottom - ARect.Top) / 2) < 3) and (Abs(X - ARect.Right) < 5)) then
- begin
- DragStyle := dsSizeRight;
- Cursor := crSizeWE;
- end;
-
- end;
- { if position-locked, override cursor change }
- if FLocked then
- Cursor := crNoDrop;
-
- if FDragging then
- begin
- { disallow drag off Parent }
- if (Left + X) < 0 then
- X := -Left;
- if (Top + Y) < 0 then
- Y := -Top;
- if (Left + X) > Parent.Width then
- X := Parent.Width - Left;
- if (Top + Y) > Parent.Height then
- Y := Parent.Height - Top;
- { display cursor & drag outline }
- if FDragStyle = dsMove then
- Cursor := DragCursor;
- SetCursor(Screen.Cursors[Cursor]);
- RubberBand(X, Y, True);
-
- end
- else
- FDragStyle := DragStyle;
-
- end;
- { perform default processing }
- inherited MouseMove(Shift, X, Y);
-
- end;
-
- procedure TStretchHandle.ForwardMessage(FwdMsg: TForwardMessage; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
- var
- i: integer;
- Found: boolean;
- Msg: Word;
- ARect: TRect;
- AControl: TControl;
- AMessage: TMessage;
- begin
- { construct the message to be sent }
- case FwdMsg of
- fmMouseDown:
- case Button of
- mbLeft:
- Msg := WM_LBUTTONDOWN;
- mbMiddle:
- Msg := WM_MBUTTONDOWN;
- mbRight:
- Msg := WM_RBUTTONDOWN;
- end;
- fmMouseUp:
- case Button of
- mbLeft:
- Msg := WM_LBUTTONUP;
- mbMiddle:
- Msg := WM_MBUTTONUP;
- mbRight:
- Msg := WM_RBUTTONUP;
- end;
- end;
-
- AMessage.WParam := 0;
- { determine whether X, Y is over any other windowed control }
- Found := False;
- for i := 0 to Parent.ControlCount - 1 do
- begin
- AControl := TControl(Parent.Controls[i]);
- if (AControl is TWinControl) and not (AControl is TStretchHandle) then
- begin
- ARect := Rect(AControl.Left,
- AControl.Top,
- AControl.Left + AControl.Width,
- AControl.Top + AControl.Height);
- { X, Y are relative to Parent }
- if PtInRect(ARect, Point(X, Y)) then
- begin
- Found := True;
- break;
- end;
- end;
- end;
- { forward the message to the control if found, else to the Parent }
- if Found then
- begin
- AMessage.LParamLo := X - AControl.Left;
- AMessage.LParamHi := Y - AControl.Top;
- SendMessage(TWinControl(AControl).Handle, Msg, AMessage.WParam, AMessage.LParam);
- end
- else
- begin
- AMessage.LParamLo := X;
- AMessage.LParamHi := Y;
- SendMessage(Parent.Handle, Msg, AMessage.WParam, AMessage.LParam);
- end;
-
- end;
-
- procedure TStretchHandle.KeyDown(var Key: Word; Shift: TShiftState);
- begin
- { process arrow keys to move/resize Handles & Child, also move siblings }
- case Key of
- VK_UP:
- begin
- Invalidate;
- SetBounds(Left, Top - 1, Width, Height);
- end;
- VK_DOWN:
- begin
- Invalidate;
- SetBounds(Left, Top + 1, Width, Height);
- end;
- VK_LEFT:
- begin
- Invalidate;
- SetBounds(Left - 1, Top, Width, Height);
- end;
- VK_RIGHT:
- begin
- Invalidate;
- SetBounds(Left + 1, Top, Width, Height);
- end;
- end;
-
- inherited KeyDown(Key, Shift);
-
- end;
-
- function TStretchHandle.GetModifiedRect(XPos, YPos: integer): TRect;
- var
- ARect: TRect;
- begin
- { compute new position/size, depending on FDragStyle}
- case FDragStyle of
-
- dsSizeTopLeft:
- begin
- ARect.Left := XGridAdjust(Left + (XPos - FDragOffset.X)) - 2;
- ARect.Top := YGridAdjust(Top + (YPos - FDragOffset.Y)) - 2;
- ARect.Right := Width - (ARect.Left - Left);
- ARect.Bottom := Height - (ARect.Top - Top);
- end;
-
- dsSizeTopRight:
- begin
- ARect.Left := Left;
- ARect.Top := YGridAdjust(Top + (YPos - FDragOffset.Y)) - 2;
- ARect.Right := XGridAdjust(Width + (XPos - FDragOffset.X)) - 3;
- ARect.Bottom := Height - (ARect.Top - Top);
- end;
-
- dsSizeBottomLeft:
- begin
- ARect.Left := XGridAdjust(Left + (XPos - FDragOffset.X)) - 2;
- ARect.Top := Top;
- ARect.Right := Width - (ARect.Left - Left);
- ARect.Bottom := YGridAdjust(Height + (YPos - FDragOffset.Y)) - 3;
- end;
-
- dsSizeBottomRight:
- begin
- ARect.Left := Left;
- ARect.Top := Top;
- ARect.Right := XGridAdjust(Width + (XPos - FDragOffset.X)) - 3;
- ARect.Bottom := YGridAdjust(Height + (YPos - FDragOffset.Y)) - 3;
- end;
-
- dsSizeTop:
- begin
- ARect.Left := Left;
- ARect.Top := YGridAdjust(Top + (YPos - FDragOffset.Y)) - 2;
- ARect.Right := Width;
- ARect.Bottom := Height - (ARect.Top - Top);
- end;
-
- dsSizeBottom:
- begin
- ARect.Left := Left;
- ARect.Top := Top;
- ARect.Right := Width;
- ARect.Bottom := YGridAdjust(Height + (YPos - FDragOffset.Y)) - 3;
- end;
-
- dsSizeLeft:
- begin
- ARect.Left := XGridAdjust(Left + (XPos - FDragOffset.X)) - 2;
- ARect.Top := Top;
- ARect.Right := Width - (ARect.Left - Left);
- ARect.Bottom := Height;
- end;
-
- dsSizeRight:
- begin
- ARect.Left := Left;
- ARect.Top := Top;
- ARect.Right := XGridAdjust(Width + (XPos - FDragOffset.X)) - 3;
- ARect.Bottom := Height;
- end;
-
- else
- { keep size, move to new position }
- ARect.Left := XGridAdjust(Left + (XPos - FDragOffset.X)) - 2;
- ARect.Top := YGridAdjust(Top + (YPos - FDragOffset.Y)) - 2;
- ARect.Right := Width;
- ARect.Bottom := Height;
-
- end;
- { impose a minimum size for sanity }
- if ARect.Right < 5 then
- ARect.Right := 5;
- if ARect.Bottom < 5 then
- ARect.Bottom := 5;
-
- Result := ARect;
-
- end;
-
- procedure TStretchHandle.Rubberband(XPos, YPos: integer; ShowBox: boolean);
- var
- NewRect: TRect;
- PtA, PtB: TPoint;
- ScreenDC: HDC;
- begin
- { outline is drawn over all windows }
- ScreenDC := GetDC(0);
- { erase previous rectangle, if any, & adjust for handle's position }
- if (FDragRect.Left <> 0) or (FDragRect.Top <> 0) or (FDragRect.Right <> 0) or (FDragRect.Bottom <> 0) then
- begin
- PtA := Parent.ClientToScreen(Point(FDragRect.Left + 2, FDragRect.Top + 2));
- PtB := Parent.ClientToScreen(Point(FDragRect.Left + FDragRect.Right - 3, FDragRect.Top + FDragRect.Bottom - 3));
- DrawFocusRect(ScreenDC, Rect(PtA.X, PtA.Y, PtB.X, PtB.Y));
- FDragRect := Rect(0, 0, 0, 0);
- end;
- { draw new rectangle unless this is a final erase }
- if ShowBox then
- begin
- NewRect := GetModifiedRect(XPos, YPos);
- PtA := Parent.ClientToScreen(Point(NewRect.Left + 2, NewRect.Top + 2));
- PtB := Parent.ClientToScreen(Point(NewRect.Left + NewRect.Right - 3, NewRect.Top + NewRect.Bottom - 3));
- DrawFocusRect(ScreenDC, Rect(PtA.X, PtA.Y, PtB.X, PtB.Y));
- FDragRect := NewRect;
- end
- else
- begin
- Parent.Repaint;
- Repaint;
- end;
-
- ReleaseDC(0, ScreenDC);
-
- end;
-
- procedure TStretchHandle.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
- var
- WasVisible: boolean;
- i: integer;
- AControl: TControl;
- begin
- { hide & preserve fixed size in design mode }
- WasVisible := Visible;
- if csDesigning in ComponentState then
- begin
- Visible := False;
- inherited SetBounds(ALeft, ATop, 24, 24);
- end
- else { move child also, if any (but only if not locked) }
- if not FLocked then
- begin
- for i := 0 to FChildList.Count - 1 do
- begin
- AControl := FChildList[i];
- AControl.SetBounds(AControl.Left - Left + ALeft,
- AControl.Top - Top + ATop,
- AControl.Width - Width + AWidth,
- AControl.Height - Height + AHeight);
- end;
- inherited SetBounds(ALeft, ATop, AWidth, AHeight);
- end;
- { restore visibility }
- if Visible = False then
- Visible := WasVisible;
-
- end;
-
- procedure TStretchHandle.Paint;
- var
- AControl: TControl;
- ARect, BoxRect: TRect;
- i: integer;
- begin
-
- inherited Paint;
- { do it differently at design time... }
- if csDesigning in ComponentState then
- begin
- Canvas.Brush.Color := FPrimaryColor;
- BoxRect := Rect(0, 0, 5, 5);
- Canvas.FillRect(BoxRect);
- BoxRect := Rect(19, 0, 24, 5);
- Canvas.FillRect(BoxRect);
- BoxRect := Rect(19, 19, 24, 24);
- Canvas.FillRect(BoxRect);
- BoxRect := Rect(0, 19, 5, 24);
- Canvas.FillRect(BoxRect);
- end
- else
- begin
- { set color to primary if only one child, else secondary }
- if FChildList.Count = 1 then
- Canvas.Brush.Color := FPrimaryColor
- else
- Canvas.Brush.Color := FSecondaryColor;
- { draw resize handles for each child }
- for i := 0 to FChildList.Count - 1 do
- begin
-
- AControl := TControl(FChildList.Items[i]);
- ARect := Rect(AControl.Left - Left - 2,
- AControl.Top - Top - 2,
- AControl.Left - Left + AControl.Width + 2,
- AControl.Top - Top + AControl.Height + 2);
-
- with Canvas do
- begin
- { draw corner boxes (assuming Canvas is minimum 5x5) }
- BoxRect := Rect(ARect.Left, ARect.Top, ARect.Left + 5, ARect.Top + 5);
- FillRect(BoxRect);
- BoxRect := Rect(ARect.Right - 5, ARect.Top, ARect.Right, ARect.Top + 5);
- FillRect(BoxRect);
- BoxRect := Rect(ARect.Right - 5, ARect.Bottom - 5, ARect.Right, ARect.Bottom);
- FillRect(BoxRect);
- BoxRect := Rect(ARect.Left, ARect.Bottom - 5, ARect.Left + 5, ARect.Bottom);
- FillRect(BoxRect);
- { only for single Children, draw center boxes }
- if FChildList.Count = 1 then
- begin
- BoxRect := Rect(ARect.Left + trunc((ARect.Right - ARect.Left) / 2) - 2,
- ARect.Top,
- ARect.Left + trunc((ARect.Right - ARect.Left) / 2) + 3,
- ARect.Top + 5);
- FillRect(BoxRect);
- BoxRect := Rect(ARect.Left + trunc((ARect.Right - ARect.Left) / 2) - 2,
- ARect.Bottom - 5,
- ARect.Left + trunc((ARect.Right - ARect.Left) / 2) + 3,
- ARect.Bottom);
- FillRect(BoxRect);
- BoxRect := Rect(ARect.Left,
- ARect.Top + trunc((ARect.Bottom - ARect.Top) / 2) - 2,
- ARect.Left + 5,
- ARect.Top + trunc((ARect.Bottom - ARect.Top) / 2) + 3);
- FillRect(BoxRect);
- BoxRect := Rect(ARect.Right - 5,
- ARect.Top + trunc((ARect.Bottom - ARect.Top) / 2) - 2,
- ARect.Right,
- ARect.Top + trunc((ARect.Bottom - ARect.Top) / 2) + 3);
- FillRect(BoxRect);
- end;
-
- end;
-
- end;
-
- end;
-
- end;
-
- procedure TStretchHandle.SetPrimaryColor(Color: TColor);
- begin
- { set single select color, repaint immediately }
- FPrimaryColor := Color;
- Repaint;
-
- end;
-
- procedure TStretchHandle.SetSecondaryColor(Color: TColor);
- begin
- { set multiple select color, repaint immediately }
- FSecondaryColor := Color;
- Repaint;
-
- end;
-
- procedure TStretchHandle.SetColors(Color1, Color2: TColor);
- begin
- { set single/multiple select colors, repaint }
- FPrimaryColor := Color1;
- FSecondaryColor := Color2;
- Repaint;
-
- end;
-
- procedure TStretchHandle.SetGridState(Value: boolean);
- begin
- { a value of 1 effectively disables a grid axis }
- if Value then
- begin
- FGridX := 8;
- FGridY := 8;
- end
- else
- begin
- FGridX := 1;
- FGridY := 1;
- end;
-
- end;
-
- function TStretchHandle.GetGridState: boolean;
- begin
-
- if (FGridX > 1) or (FGridY > 1) then
- Result := True
- else
- Result := False;
-
- end;
-
- function TStretchHandle.GetChildCount: integer;
- begin
- Result := FChildList.Count;
- end;
-
- function TStretchHandle.GetChildControl(idx: integer): TControl;
- begin
-
- if (FChildList.Count > 0) and (idx >= 0) then
- Result := FChildList[idx]
- else
- Result := nil;
-
- end;
-
- function TStretchHandle.IsAttached: boolean;
- begin
-
- if FChildList.Count > 0 then
- Result := True
- else
- Result := False;
-
- end;
-
- function TStretchHandle.PointOverChild(P: TPoint): boolean;
- var
- i: integer;
- ARect: TRect;
- AControl: TControl;
- begin
- { determine whether X, Y is over any child (for dragging) }
- Result := False;
- for i := 0 to FChildList.Count - 1 do
- begin
- AControl := TControl(FChildList[i]);
- ARect := Rect(AControl.Left - 2,
- AControl.Top - 2,
- AControl.Left + AControl.Width + 2,
- AControl.Top + AControl.Height + 2);
- { P is relative to the Parent }
- if PtInRect(ARect, P) then
- begin
- Result := True;
- break;
- end;
- end;
-
- end;
-
- function TStretchHandle.XGridAdjust(X: integer): integer;
- begin
- Result := (X DIV FGridX) * FGridX;
- end;
-
- function TStretchHandle.YGridAdjust(Y: integer): integer;
- begin
- Result := (Y DIV FGridY) * FGridY;
- end;
-
- function MinInt(a, b: integer): integer;
- begin
- if a < b then
- Result := a
- else
- Result := b;
- end;
-
- function MaxInt(a, b: integer): integer;
- begin
- if a > b then
- Result := a
- else
- Result := b;
- end;
-
- end.
-